perm filename BBB[LSP,BGB] blob
sn#017669 filedate 1972-12-27 generic text, type T, neo UTF8
00100 SUBTTL TYI AND TYO --- PAGE 6
00200 ;INPUT
00300 ITYI: PUSHJ P,TYI
00400 FIXI: ADDI A,INUM0
00500 POPJ P,
00600
00700 TYI: MOVEI AR1,1
00800 PUSHJ P,TYIA
00900 JUMPE A,.-1
01000 CAME A,IGSTRT ;start of comment or ignored cr-lf
01100 POPJ P,
01200 PUSHJ P,COMMENT
01300 JRST TYI+1
01400
01500 TYIA: SKIPE A,OLDCH
01600 JRST TYI1
01700 TYID:
01800 TYI2: JRST TTYI+X ;sosg x for other device INPUT
01900 ;other device INPUT
02000 JRST TYI2X
02100 TYI3: ILDB A,X ;pointer
02200 TYI3A: TDNN AR1,@X ;pointer
02300 POPJ P,
02400 LAC A,@TYI3A
02500 CAMN A,[<ASCII / />+1] ;page mark for stopgap
02600 AOSA PGNUM ;increment page number
02700 DAC A,LINUM
02800 MOVNI A,5
02900 ADDM A,@TYI2 ;adjust character count for line number
03000 AOS @TYI3 ;increment byte pointer over line number and tab
03100 JRST TYI2
03200
03300 TYI2X: INPUT X,
03400 TYI2Y: STATZ X,740000
03500 ERR1 AIN.8 ;INPUT error
03600 TYI2Z: STATO X,20000
03700 JRST TYI3 ;continue with file
03800 PUSH P,T ;end of file
03900 PUSH P,C
04000 PUSH P,R
04100 PUSH P,AR1
04200 LAC A,INCH
04300 CDR C,CHTAB(A) ;get location of data for this channel
04400 CAR T,CHTAB(A) ;inlst -- remaining files to INPUT
04500 JUMPE T,TYI2E ;none left -- stop
04600 PUSHJ P,SETIN ;start next INPUT
04700 POP P,AR1
04800 POP P,R
04900 POP P,C
05000 POP P,T
05100 JRST TYI
05200
05300 TYI2E: PUSHJ P,INCNT ;(inc nil t)
05400 TALK ;turn off control o
05500 FOO MOVEI A,$EOF$ ;we are done
05600 JRST ERR
05700
05800 PGLINE: LAC C,[POINT 7,LINUM]
05900 PUSHJ P,NUM10 ;convert ascii line number to a integer
06000 PUSHJ P,FIX1A
06100 LAC B,PGNUM
06200 ADDI B,INUM0+1
06300 JRST XCONS
06400
06500 OLDCH: 0
06600 PGNUM: 0
06700 LINUM: 0
06800 0 ;zero to terminate num10
00100 ;teletype INPUT
00200
00300 TTYI: SKIPE DDTIFG
00400 JRST TTYID
00500 INCHSL A ;single char if line has been typed
00600 JRST [TALK ;turn off control O, this
00700 ;can be omitted when TTYSER is fixed
00800 OUTCHR ["*"] ;output *
00900 INCHWL A ;wait for a line
01000 JRST .+1]
01100 TTYXIT: CAIN A,BELL
01200 JRST LSPRET ;bell returns to top level
01300 POPJ P,
01400
01500 TTYID: TALK ;turn off control O, remove this when TTYSER works
01600 INCHRW A ;single character INPUT DDT submode style
01700 CAIE A,RUBOUT
01800 JRST TTYXIT
01900 OUTCHR ["\"] ;echo backslash
02000 SKIPE PSAV
02100 JRST RDRUB ;rubout in read resets to top level of read
02200 MOVEI A,RUBOUT
02300 POPJ P,
00100 ;output
00200 ITYO: SUBI A,INUM0
00300 PUSHJ P,TYO
00400 JRST FIXI
00500
00600 TYO: CAIG A,CR
00700 JRST TYO3
00800 SOSGE CHCT
00900 JRST TYO1
01000 TYOD: JRST TTYO+X ;sosg x for other device
01100 ;other device output
01200 JRST TYO2X
01300 TYO5: IDPB A,X
01400 POPJ P,
01500
01600 TYO2X: OUT X,
01700 JRST TYO5
01800 ERR1 [SIXBIT /OUTPUT ERROR!/]
01900
02000 TYO1: PUSH P,A ;linelength exceeded
02100 MOVEI A,IGCRLF ;inored cr-lf
02200 PUSHJ P,TYOD
02300 PUSHJ P,TERPRI ;force out a cr-lf, with special mark
02400 POP P,A
02500 SOSA CHCT
02600 TYO4: POP P,B
02700 JRST TYOD
02800
02900 TYO3: CAIGE A,TAB
03000 JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
03100 PUSH P,B
03200 LAC B,LINL
03300 CAIN A,TAB
03400 JRST [ SUB B,CHCT
03500 IORI B,7 ;simulate tab effect on chct
03600 SUB B,LINL
03700 SETCAM B,CHCT
03800 JRST TYO4]
03900 CAIN A,CR
04000 DAC B,CHCT ;reset chct after a cr
04100 JRST TYO4
04200
04300 LINELENGTH:
04400 JUMPE A,LINEL1
04500 SUBI A,INUM0
04600 DAC A,CHCT
04700 EXCH A,LINL
04800 JRST FIXI
04900 LINEL1: LAC A,LINL
05000 JRST FIXI
05100
05200 CHRCT: LAC A,CHCT
05300 JRST FIXI
05400
05500 LINL: TTYLL ;*
05600 CHCT: TTYLL ;*
05700
05800 ;teletype output
05900 TTYO: OUTCHR A ;output single character in a
06000 POPJ P,
00100 DDTIFG: TRUTH
00200 DDTIN: EXCH A,DDTIFG
00300 POPJ P,
00400
00500
00600 TTYRET: PUSHJ P,OUTCNT
00700 JRST INCNT
00800
00900 ;all of this crap is to turn off control O. lose-lose-lose
01000 TTYCLR: RELEASE TTCH,
01100 INIT TTCH,1
01200 SIXBIT /TTY/
01300 XWD TOBUF,0
01400 HALT
01500 PUSH P,A
01600 MOVEI A,TTOBUF-1
01700 DAC A,JOBFF
01800 OUTBUF TTCH,1
01900 OUTPUT TTCH, ;set up buffer
02000 MOVEI A,0
02100 IDPB A,TOBUF+1 ;plant a null character
02200 AOS TOBUF+2
02300 OUTPUT TTCH, ;output it
02400 JRST POPAJ
02500
02600 TOBUF: BLOCK 3
02700
02800 TTOBUF: BLOCK 33
02900
03000 TTOCH: 0 ;*
03100 0 ;tty page number always zero
03200 0 ;tty line number -- always zero
03300
03400 TTOLL: TTYLL ;*
03500 TTOHP: TTYLL ;*
00100 SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
00200 ;convert ascii to sixbit for device initialization routines
00300 SIXMAK: SETZM SIXMK2#
00400 LAC AR1,[POINT 6,SIXMK2]
00500 HRROI R,SIXMK1
00600 PUSHJ P,PRINTA ;use print to unpack ascii characters
00700 LAC A,SIXMK2
00800 POPJ P,
00900
01000 SIXMK1: ADDI A,40
01100 TLNN AR1,770000
01200 POPJ P, ;last character position -- ignore remaining chars
01300 CAIN A,"."+40
01400 MOVEI A,0 ;ignore dots at end of numbers for decimal base
01500 CAIN A,":"+40
01600 HRLI AR1,(<POINT 6,0,29>) ;deposit : in last char
01700 IDPB A,AR1
01800 POPJ P,
01900
02000 ;subroutine to process next item in file name list
02100 INXTIO: JUMPE T,NXTIO
02200 CDR T,(T)
02300 NXTIO: CAR A,(T)
02400 PUSHJ P,ATOM
02500 JUMPE A,CPOPJ ;non-atomic
02600 CAR A,(T)
02700 JRST SIXMAK ;make sixbit if atomic
02800
02900 ;right normalize sixbit
03000 LSH A,-6
03100 SIXRT: TRNN A,77
03200 JRST .-2
03300 POPJ P,
00100 IOSUB: PUSHJ P,NXTIO
00200 DAC T,DEVDAT#
00300 LDB B,[POINT 6,A,35]
00400 JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
00500 CAIE B,":"-40
00600 JRST IOFIL ;not a device name -- must be file name
00700 TRZ A,77 ;clear out the :
00800 SETZM PPN
00900 IODEV2: DAC A,DEV
01000 PUSHJ P,INXTIO
01100 IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
01200 PUSHJ P,PPNEXT
01300 JUMPN A,IOEXT ;(fil.ext)
01400 CAR A,(T)
01500 CAR A,(A) ;caar is project number
01600 PUSHJ P,SIXMAK
01700 PUSHJ P,SIXRT
01800 DIP A,PPN ;project number
01900 CAR A,(T)
02000 PUSHJ P,CADR ;cadar is programmer number
02100 PUSHJ P,SIXMAK
02200 PUSHJ P,SIXRT
02300 DAP A,PPN ;programmer number
02400 HRLZI A,(<SIXBIT /DSK/>) ;disk is assumed
02500 JRST IODEV2
02600
02700 IOFIL: SKIPN DEV
02800 JRST AIN.1 ;no device named
02900 JUMPN A,IOFIL2 ;was it an atom
03000 JUMPE T,CPOPJ ;no, was it nil (end)
03100 PUSHJ P,PPNEXT
03200 JUMPE A,CPOPJ ;see a ppn, no file named
03300 IOEXT: CAR A,(T) ;(file.ext)
03400 CDR A,(A) ;get cdr ←← extension
03500 PUSHJ P,SIXMAK
03600 HLLM A,EXT
03700 CAR A,(T)
03800 CAR A,(A) ;get car = file name
03900 PUSHJ P,SIXMAK
04000 FIL: PUSH P,A
04100 PUSHJ P,INXTIO
04200 JRST POPAJ
04300
04400 IOFIL2: CAIN B,":"-40
04500 POPJ P, ;saw a :,not file name
04600 SETZM EXT ;file name -- clear extension
04700 JRST FIL
04800
04900 PPNEXT: JUMPE T,CPOPJ ;end of file name list
05000 CAR A,(T)
05100 CDR A,(A) ;cdar
05200 JRST ATOM ;ppn iff (not(atom(cdar l)))
05300
05400 CHNSUB: LAC T,A
05500 CAR A,(T)
05600 PUSHJ P,ATOM
05700 JUMPE A,TRUE ;non-atomic head of list -- no channel named
05800 CAR A,(T)
05900 PUSHJ P,SIXMAK
06000 ANDI A,77
06100 CAIN A,":"-40
06200 JRST TRUE ;device name, assume channel name t
06300 CAR A,(T) ;channel name -- return it
06400 CDR T,(T)
06500 POPJ P,
06600
06700 CHTAB←.-FSTCH
06800 BLOCK NIOCH ;*
06900
07000 ;channel data
07100 CHNAM←←0 ;name of channel
07200 CHDEV←←1 ;name of device
07300 CHPPN←←2 ;ppn for INPUT channel
07400 CHOCH←←3 ;oldch for INPUT channels
07500 CHPAGE←←4 ;page number for INPUT
07600 CHLINE←←5 ;line number for INPUT
07700 CHDAT←←6 ;device data
07800 POINTR←←7 ;byte pointer for device buffer
07900 COUNT←←10 ;character count for device buffer
08000 CHLL←←2 ;linelength for output channel
08100 CHHP←←3 ;hposit for output channels
00100 ;search for channel name in chtab
00200 TABSR1: LAC A,[XWD -NIOCH,FSTCH]
00300 LAC C,CHTAB(A)
00400 CAME B,CHNAM(C)
00500 AOBJN A,.-2
00600 CAMN B,CHNAM(C)
00700 POPJ P, ;found it!!!
00800 JRST FALSE ;lost
00900
01000 ;search for channel name in chtab, and if not there find a free channel, and
01100 ;if no free channel, allocate a new buffer and channel
01200 TABSRC: LAC B,A
01300 PUSHJ P,TABSR1
01400 JUMPN A,DEVCLR ;found the channel
01500 PUSH P,B
01600 LAC B,0
01700 PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
01800 JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
01900 POP P,B
02000 JUMPN C,DEVCLR ;found free channel which had buffer space previously
02100 PUSH P,A ;must allocate new buffer
02200 MOVEI A,BLKSIZ
02300 PUSHJ P,MORCOR ;Get space for buffer.
02400 LAC C,A
02500 POP P,A
02600 DAP C,CHTAB(A)
02700 DEVCLR: CDR C,CHTAB(A)
02800 DAPZ B,CHNAM(C) ;store name
02900 DAPZ A,CHANNEL#
03000 POPJ P,
03100
03200 ;subroutine to reset all i/o channels -- used by excise and realloc
03300 IOBRST: X ;jsr location
03400 ;CDR A,JOBREL
03500 ;DIP A,JOBSA
03600 ;DAC A,CORUSE#
03700 ;DAC A,JOBSYM
03800 ;SETZM CHTAB+FSTCH
03900 ;LAC A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
04000 ;BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
04100 JRST @IOBRST
00100 INPUT: PUSHJ P,CHNSUB ;determine channel name
00200 PUSH P,A
00300 PUSHJ P,TABSRC ;get physical channel number
00400 PUSHJ P,SETIN ;init device
00500 JRST POPAJ
00600
00700 SETIN: DAC A,CHANNEL
00800 LAC A,CHDEV(C)
00900 DAC A,DEV
01000 LAC A,CHPPN(C)
01100 DAC A,PPN
01200 PUSHJ P,IOSUB ;get device and file name
01300 DAC A,LOOKIN ;file name
01400 LAC A,DEV
01500 CALLI A,DEVCHR
01600 TLNN A,INB
01700 JRST AIN.2 ;not INPUT device
01800 TLNN A,AVLB
01900 JRST AIN.4 ;not available
02000 LAC A,CHANNEL
02100 DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
02200 DPB A,[POINT 4,INLOOK,ACFLD]
02300 DPB A,[POINT 4,ININBF,ACFLD]
02400 CDR B,CHTAB(A)
02500 DIP T,CHTAB(A) ;save remaining file name list
02600 MOVEI A,CHDAT(B)
02700 DAC A,DEV+1 ;pointer to bufdat
02800 ININIT: INIT X,
02900 DEV: X
03000 X
03100 JRST AIN.7 ;cant init
03200 PUSH B,DEV
03300 PUSH B,PPN
03400 INLOOK: LOOKUP X,LOOKIN
03500 JRST AIN.7 ;cant find file
03600 PUSH B,[0] ;oldch
03700 PUSH B,[0] ;line number
03800 PUSH B,[0] ;page number
03900 ADDI B,4
04000 DAP B,JOBFF
04100 ININBF: INBUF X,NIOB
04200 JRST TRUE
04300
04400 ENTR:
04500 LOOKIN: BLOCK 4
04600 EXT←LOOKIN+1
04700 PPN←LOOKIN+3
00100 OUTPUT: PUSHJ P,CHNSUB ;get channel name
00200 PUSH P,A
00300 TRO A,400000 ;set bit for output
00400 PUSHJ P,TABSRC ;get physical channel nuber
00500 PUSHJ P,IOSUB ;get device and file name
00600 DAC A,ENTR ;file name
00700 SETZM ENTR+2 ;zero creation date
00800 LAC A,CHANNEL
00900 DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
01000 DPB A,[POINT 4,OUTENT,ACFLD]
01100 DPB A,[POINT 4,OUTOBF,ACFLD]
01200 CDR B,CHTAB(A)
01300 MOVEI A,CHDAT(B)
01400 DIP A,AOUT3+1
01500 LAC A,DEV
01600 DAC A,AOUT3
01700 CALLI A,DEVCHR
01800 TLNN A,OUTB
01900 JRST AOUT.2 ;not output device
02000 TLNN A,AVLB
02100 JRST AOUT.4 ;not available
02200 AOUT2: INIT X,
02300 AOUT3: X
02400 X
02500 JRST AOUT.4 ;cant init
02600 PUSH B,DEV
02700 OUTENT: ENTER X,ENTR
02800 JRST OUTERR ;cant enter
02900 PUSH B,[LPTLL] ;linelength
03000 PUSH B,[LPTLL] ;chrct
03100 ADDI B,6
03200 DAP B,JOBFF
03300 OUTOBF: OUTBUF X,NIOB
03400 JRST POPAJ
03500
03600 OUTERR: PUSHJ P,AIOP
03700 LDB A,[POINT 3,ENTR+1,35]
03800 CAIE A,2
03900 ERR1 [SIXBIT /DIRECTORY FULL !/]
04000 ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
00100 IOSEL: LAC C,-1(P)
00200 JUMPE C,CPOPJ ;tty
00300 JUMPE B,IOSELZ ;dont release
00400 DPB C,[POINT 4,.+1,ACFLD]
00500 RELEASE X, ;release channel
00600 HRRZS CHTAB(C) ;release channel table entry
00700 DAC 0,@CHTAB(C) ;blast channel name
00800 SETZM -1(P)
00900 IOSELZ: CDR C,CHTAB(C)
01000 POPJ P,
00100 INCNT: MOVEI A,NIL ;(INC NIL T)
00200 MOVEI B,TRUTH
00300
00400 INC: PUSH P,INCH#
00500 PUSHJ P,IOSEL
00600 JUMPN B,INC2 ;released channel
00700 SKIPN C
00800 MOVEI C,TTOCH-CHOCH ;tty deselect
00900 MOVEI B,CHOCH(C)
01000 HRLI B,OLDCH
01100 BLT B,CHLINE(C) ;save channel data
01200 INC2: JUMPE A,ITTYRE ;select tty
01300 LAC B,A
01400 PUSHJ P,TABSR1 ;determine physical channel number
01500 JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
01600 DAPZ A,INCH
01700 DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
01800 DPB A,[POINT 4,TYI2Y,ACFLD]
01900 DPB A,[POINT 4,TYI2Z,ACFLD]
02000 CDR A,CHTAB(A)
02100 MOVEI T,COUNT(A)
02200 HRLI T,(<SOSG>)
02300 MOVEI B,POINTR(A)
02400 DAP B,TYI3 ;set up tyi parameters
02500 DAP B,TYI3A
02600 INC3: MOVSI B,CHOCH(A)
02700 HRRI B,OLDCH
02800 BLT B,LINUM ;restore channel data
02900 DAC T,TYID
03000 IOEND: POP P,A
03100 JUMPE A,CPOPJ
03200 LAC A,CHTAB(A) ;get channel name
03300 CDR A,(A)
03400 TRZ A,400000 ;clear output bit
03500 POPJ P,
03600
03700 ITTYRE: SETZM INCH
03800 LAC T,[JRST TTYI] ;reselect tty
03900 MOVEI A,TTOCH-CHOCH
04000 JRST INC3
00100 OUTCNT: MOVEI A,0 ;(outc nil t)
00200 MOVEI B,1
00300
00400 OUTC: PUSH P,OUTCH#
00500 PUSHJ P,IOSEL
00600 JUMPN B,OUTC2 ;closed this file
00700 SKIPN C
00800 MOVEI C,TTOLL-CHLL ;tty deselect
00900 LAC B,CHCT
01000 DAC B,CHHP(C) ;save channel data
01100 LAC B,LINL
01200 DAC B,CHLL(C)
01300 OUTC2: JUMPE A,OTTYRE ;return to tty
01400 TRO A,400000 ;set output bit
01500 LAC B,A
01600 PUSHJ P,TABSR1 ;determine physical channel number
01700 JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
01800 DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
01900 DAPZ A,OUTCH
02000 CDR A,CHTAB(A)
02100 MOVEI B,POINTR(A)
02200 DAP B,TYO5 ;set up tyo2 parameters
02300 MOVEI T,COUNT(A)
02400 HRLI T,(<SOSG>)
02500 OUTC3: LAC B,CHLL(A)
02600 DAC B,LINL
02700 LAC B,CHHP(A)
02800 DAC B,CHCT
02900 DAC T,TYOD
03000 JRST IOEND
03100
03200 OTTYRE: SETZM OUTCH
03300 LAC T,[JRST TTYO]
03400 MOVEI A,TTOLL-CHLL ;tty reselect
03500 JRST OUTC3
00100 AIN.1: PUSHJ P,AIOP
00200 ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
00300 AOUT.2:
00400 AIN.2: PUSHJ P,AIOP
00500 ERR1 [SIXBIT /ILLEGAL DEVICE!/]
00600 AOUT.4:
00700 AIN.4: PUSHJ P,AIOP
00800 ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
00900 AIN.7: PUSHJ P,AIOP
01000 ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
01100
01200 AIN.8: SIXBIT /INPUT ERROR!/
01300
01400 AIOP: LAC A,DEVDAT
01500 JRST EPRINT
00100 SUBTTL PRINT --- PAGE 8
00200
00300 EPRINT: SKIPN ERRSW
00400 POPJ P,
00500 PUSHJ P,ERRIO
00600 PUSHJ P,PRINT
00700 JRST OUTRET
00800
00900 PRINT: MOVEI R,TYO
01000 PUSHJ P,TERPRI
01100 PUSHJ P,PRIN1
01200 XCT " ",CTY
01300 POPJ P,
01400
01500 PRINC: SKIPA R,.+1
01600 PRIN1: HRRZI R,TYO
01700 PUSH P,A
01800 PUSHJ P,PRINTA
01900 JRST POPAJ
02000
02100 PRINTA: PUSH P,A
02200 MOVEI B,PRIN3
02300 SKIPGE R
02400 MOVEI B,PRIN4
02500 DAP B,PRIN5
02600 PUSHJ P,PATOM
02700 JUMPN A,PRINT1
02800 XCT "(",CTY
02900 PRINT3: CAR A,@(P)
03000 PUSHJ P,PRINTA
03100 CDR A,@(P)
03200 JUMPE A,PRINT2
03300 DAC A,(P)
03400 XCT " ",CTY
03500 PUSHJ P,PATOM
03600 JUMPE A,PRINT3
03700 XCT ".",CTY
03800 XCT " ",CTY
03900 PUSHJ P,PRIN1A
04000 PRINT2: XCT ")",CTY
04100 JRST POPAJ
04200
04300 PRINT1: PUSHJ P,PRIN1A
04400 JRST POPAJ
00100 PRIN1A: LAC A,-1(P)
00200 CAILE A,INUMIN
00300 JRST PRINIC
00400 JUMPE A,PRIN1B
00500 CAMGE A,orgFWS
00600 CAMGE A,orgHWS
00700 JRST PRINL
00800 PRIN1B: CDR A,(A)
00900 JUMPE A,PRINL
01000 CAR B,(A)
01100 CDR A,(A)
01200 FOO CAIN B,PNAME
01300 JRST PRINN
01400 FOO CAIN B,FIXNUM
01500 JRST PRINI1
01600 FOO CAIN B,FLONUM
01700 JRST PRINO
01800 BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
01900 JRST PRIN1B
02000
02100 PRINL2: MOVEI R,TYO
02200 JRST PRINL1
02300
02400 PRINL: XCT "#",CTY
02500 CDR A,-1(P)
02600 PRINL1: MOVEI C,8
02700 JRST PRINI3
02800
02900 PRINI1: SKIPA A,(A)
03000 PRINIC: SUBI A,INUM0
03100 FOO CDR C,VBASE
03200 SUBI C,INUM0
03300 JUMPGE A,PRINI2
03400 XCT "-",CTY
03500 MOVNS A
03600 PRINI2: MOVEI B,"."-"0"
03700 DIP B,(P)
03800 CAIN C,TEN
03900 FOO SKIPE %NOPOINT
04000 JRST .+2
04100 PUSH P,PRINI4
04200 PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
04300 MOVEI A,1
04400 DIVI A,(C)
04500 JRST .+2]
04600 IDIVI A,0(C)
04700 DIP B,(P)
04800 SKIPE A
04900 PUSHJ P,.-3
05000 PRINI4: JRST FP7A1
05100
05200 PRINN: CAR A,(A)
05300 MOVEI C,2(SP)
05400 PUSHJ P,PNAMU3
05500 PUSH C,[0]
05600 HRLI C,(<POINT 7,0,35>)
05700 HRRI C,2(SP)
05800 ILDB A,C
05900 JUMPE A,CPOPJ ;special case of null character
06000 CAIN A,DBLQT
06100 JRST PSTR ;string
06200 PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
06300 JUMPL R,PRIN4 ;never slash
06400 JRST PRIN2(B) ;1 for no slash
06500
06600 PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
06700 PRIN2: XCT "/",CTY
06800 PRIN4: PUSHJ P,(R)
06900 ILDB A,C
07000 PRIN5: JUMPN A,PRIN3 ;prin4 for never slash
07100 POPJ P,
07200
07300 PSTR: MOVS B,(C)
07400 CAIN B,(<ASCII /"/>)
07500 JRST PRIN2X ;special case of /"
07600 PSTR3: SKIPL R ;dont print " if no slashify
07700 PSTR2: PUSHJ P,(R)
07800 ILDB A,C
07900 CAIE A,DBLQT
08000 JUMPN A,PSTR2
08100 JUMPN A,PSTR3
08200 POPJ P,
08300
08400 TERPRI: PUSH P,A
08500 MOVEI A,CR
08600 PUSHJ P,TYO
08700 MOVEI A,LF
08800 PUSHJ P,TYO
08900 JRST POPAJ
09000
09100 CTY: JSA A,TYOI
09200 TYOI: X
09300 PUSH P,A
09400 LDB A,[POINT 6,-1(A),ACFLD]
09500 PUSHJ P,(R)
09600 POP P,A
09700 JRA A,(A)
09800
09900 PRINO: LAC A,(A)
10000 SETZB B,C
10100 JUMPG A,FP1
10200 JUMPE A,FP3
10300 MOVNS A
10400 XCT "-",CTY
10500 FP1: CAMGE A,FT01
10600 JRST FP4
10700 CAML A,FT8
10800 AOJA B,FP4
10900
11000 FP3: MULI A,400
11100 ASHC B,-243(A)
11200 LAC A,B
11300 SETZM FPTEM#
11400 PUSHJ P,FP7
11500 XCT ".",CTY
11600 MOVNI T,8
11700 ADD T,FPTEM
11800 LAC B,C
11900
12000 FP3A: LAC A,B
12100 MULI A,TEN
12200 PUSHJ P,FP7B
12300 SKIPE B
12400 AOJL T,FP3A
12500 POPJ P,
12600
12700 FP4: MOVNI C,6
12800 MOVEI TT,0
12900 FP4A: ADDI TT,1(TT)
13000 XCT FCP(B)
13100 TRZA TT,1
13200 FMPR A,@FCP+1(B)
13300 AOJN C,FP4A
13400 PUSH P,TT
13500 MOVNI B,-2(B)
13600 DPB B,[POINT 2,FP4C,11]
13700 PUSHJ P,FP3
13800 MOVEI A,"E"
13900 PUSHJ P,(R)
14000 FP4C: XCT "+"+X,CTY
14100 POP P,A
14200 FP7: JUMPE A,FP7A1
14300 IDIVI A,TEN
14400 AOS FPTEM
14500 DIP B,(P)
14600 JUMPE A,FP7A1
14700 PUSHJ P,FP7
14800
14900 FP7A1: HLRE A,(P)
15000 FP7B: ADDI A,"0"
15100 JRST (R)
15200
15300 353473426555 ;1e32
15400 266434157116 ;1e16
15500 FT8: 1.0E8
15600 1.0E4
15700 1.0E2
15800 1.0E1
15900 FT: 1.0E0
16000 026637304365 ;1e-32
16100 113715126246 ;1e-16
16200 146527461671 ;1e-8
16300 163643334273 ;1e-4
16400 172507534122 ;1e-2
16500 FT01: 175631463146 ;1e-1
16600 FT0:
16700 FCP: CAMLE A,FT0(C)
16800 CAMGE A,FT(C)
16900 XWD C,FT0
17000
00100 SUBTTL TABLE DRIVEN READ 14-MAY-69 PAGE 9
00200
00300 ;magic scanner table bit definitions
00400
00500 ;bit 0=0 iff slashified as 1st id character
00600 ;bit 1=0 iff slashified as nth id character
00700 ;bits 2-5 ratab index
00800 ;bits 6-8 dotab index
00900 ;bits 9-10 strtab index
01000 ;bits 11-13 idtab index
01100 ;bits 14-16 exptab index
01200 ;bits 17-19 rdtab index
01300 ;bits 20-25 ascii to radix 50 conversion
01400
01500 IGSTRT: IGCRLF
01600 IGEND: LF
01700
01800 RATFLD: POINT 4,CHRTAB(A),5
01900 STRFLD: POINT 2,CHRTAB(A),10
02000 IDFLD: POINT 3,CHRTAB(A),13
02100 DOTFLD:
02200 NUMFLD: POINT 3,CHRTAB(A),8
02300 EXPFLD: POINT 3,CHRTAB(A),16
02400 RDFLD: POINT 3,CHRTAB(A),19
02500 R50FLD: POINT 6,CHRTAB(A),25
02600
02700 ;magic state flags in t
02800 EXP←←1 ;exponent
02900 NEXP←←2 ;negative exponent
03000 SAWDOT←←4 ;saw a dot (.)
03100 MINSGN←←10 ;negative number
03200
03300 IDCLS←←0 ;identifier
03400 STRCLS←←1 ;string
03500 NUMCLS←←2 ;number
03600 DELCLS←←3 ;delimiter
03700
00100 ;macros for scanner table
00200
00300 DEFINE RAD50 (X){
00400 R50VAL←0
00500 IFE ("X"-" "),{R50VAL←0}
00600 IFLE ("X"-"9"),{IFGE ("X"-"0"),{R50VAL←"X"-"0"+1}}
00700 IFE ("X"-"."),{R50VAL←45}
00800 IFGE ("X"-"A"),{R50VAL←"X"-"A"+13}
00900 }
01000
01100 DEFINE TABIN (S1,SN,R,D,S,I,E,RD,STR){
01200 XLIST
01300 FOR CHRε{STR}{RAD50(CHR)
01400 BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL
01500 }
01600 LIST}
01700
01800 DEFINE LET (X){
01900 TABIN (1,1,5,2,3,4,2,0,X)}
02000
02100 DEFINE DELIMIT (X,Y){
02200 TABIN (0,0,2,2,3,2,2,Y,X)}
02300
02400 DEFINE IGNORE (X){
02500 TABIN (0,0,3,2,3,2,2,0,X)}
00100 CHRTAB:
00200 TABIN (0,0,1,1,1,1,1,0,{ })
00300 ;null
00400 LET ({ })
00500 IGNORE ({ })
00600 ;tab,lf,vtab,ff,cr
00700 LET ({ })
00800 ;16 to 31
00900 TABIN (0,0,0,0,0,0,0,0,{ })
01000 ;igmrk
01100 LET ({ })
01200 ;33 to 37
01300 IGNORE ({ })
01400 ;space
01500 LET ({ })
01600 ;!
01700 TABIN (0,0,9,2,2,2,2,0,{ })
01800 ;"
01900 LET ({ $% })
02000 ;#$%&'
02100 DELIMIT ({ },0)
02200 DELIMIT ({ },1)
02300 ;()
02400 LET ({ })
02500 ;*
02600 TABIN (1,0,3,2,3,4,2,0,{ })
02700 ;+
02800 IGNORE ({ })
02900 ;,
03000 TABIN (1,0,6,2,3,4,2,0,{ })
03100 ;-
03200 TABIN (0,0,7,3,3,2,2,4,{.})
03300 TABIN (0,0,4,2,3,3,2,0,{ })
03400 ;/
03500 TABIN (1,0,8,5,3,4,3,0,{0123456789})
03600 LET ({ })
03700 ;:;<=>?
03800 TABIN (1,0,2,2,3,4,2,5,{ })
03900 ;@
04000 LET ({ABCD})
04100 TABIN (1,1,5,4,3,4,2,0,{E})
04200 LET ({FGHIJKLMNOPQRSTUVWXYZ})
04300 DELIMIT ({ },2)
04400 ;[
04500 LET ({ })
04600 ;\
04700 DELIMIT ({ },3)
04800 ;]
04900 LET ({ })
05000 ;↑←`
05100 LET ({ABCDEFGHIJKLMNOPQRSTUVWXYZ})
05200 ;lower case
05300 LET ({ })
05400 ;{¬
05500 DELIMIT ({ },3)
05600 ;altmode
05700 LET ({ })
05800 ;}
05900 DELIMIT ({ },6)
06000 ;rubout
00100 READCH: PUSHJ P,TYI
00200 MOVSI AR1,AR1
00300 PUSHJ P,EXPL1
00400 JRST CAR.
00500
00600 READP1: SETZM NOINFG
00700 READ0: PUSH P,TYID
00800 PUSH P,OLDCH
00900 SETZM OLDCH#
01000 HRLI A,(<JRST>)
01100 DAC A,TYID
01200 PUSHJ P,READ+1
01300 POP P,OLDCH
01400 POP P,TYID
01500 POPJ P,
01600
01700 RDRUB: MOVEI A,CR
01800 PUSHJ P,TTYO
01900 MOVEI A,LF
02000 PUSHJ P,TTYO
02100 SKIPA P,PSAV#
02200 READ: SETZM NOINFG# ;0 means intern
02300 DAC P,PSAV
02400 PUSHJ P,READ1
02500 SETZM PSAV
02600 POPJ P,
02700
02800 READ1: PUSHJ P,RATOM
02900 POPJ P, ;atom
03000 XCT RDTAB2(B)
03100 JRST READ1 ;try again
03200
03300 RDTAB2: JRST READ2 ;0 (
03400 JFCL ;1 )
03500 JRST READ4 ;2 [
03600 JFCL ;3 ],$
03700 JFCL ;4 .
03800 JRST RDQT ;5 @
03900
04000 READ2: PUSHJ P,RATOM
04100 JRST READ2A ;atom
04200 XCT RDTAB(B)
04300
04400 READ2A: PUSH P,A
04500 PUSHJ P,READ2
04600 POP P,B
04700 JRST XCONS
04800
04900 RDTAB: PUSHJ P,READ2 ;0 (
05000 JRST FALSE ;1 )
05100 PUSHJ P,READ4 ;2 [
05200 JRST READ5 ;3 ],$
05300 JRST RDT ;4 .
05400 PUSHJ P,RDQT ;5 @
05500
05600 RDTX: PUSHJ P,RATOM
05700 POPJ P, ;atom
05800 XCT RDTAB2(B)
05900 JRST DOTERR ;dot context error
06000
06100 RDT: PUSHJ P,RDTX
06200 PUSH P,A
06300 PUSHJ P,RATOM
06400 JRST DOTERR
06500 CAIN B,1
06600 JRST POPAJ
06700 CAIE B,3
06800 JRST DOTERR
06900 DAC A,OLDCH
07000 JRST POPAJ
07100
07200
07300 READ4: PUSHJ P,READ2
07400 LAC B,OLDCH
07500 CAIE B,ALTMOD
07600 TYI1: SETZM OLDCH ;kill the ]
07700 POPJ P,
07800
07900 READ5: DAC A,OLDCH ;save ] or $
08000 JRST FALSE ;and return nil
08100
08200
08300 RDQT: PUSHJ P,READ1
08400 JRST QTIFY
00100 ;atom parser
00200
00300 COMMENT: PUSHJ P,TYID
00400 CAME A,IGEND
00500 JRST COMMENT
00600 POPJ P,
00700
00800 RATOM: SETZB T,R
00900 HRLI C,(<POINT 7,0,35>)
01000 HRRI C,(SP)
01100 MOVEI AR1,1
01200 RATOM2: PUSHJ P,TYIA
01300 LDB B,RATFLD
01400 JRST RATAB(B)
01500
01600 RATAB: PUSHJ P,COMMENT ;0 comment
01700 JRST RATOM2 ;1 null
01800 JRST RATOM3 ;2 delimit
01900 JRST RATOM2 ;3 ignore
02000 PUSHJ P,TYI ;4 /
02100 JRST RDID ;5 letter
02200 JRST RDNMIN ;6 -
02300 JRST RDOT ;7 .
02400 JRST RDNUM ;8 digit
02500 JRST RDSTR ;9 string
02600
02700 ;a real dotted pair
02800 RDOT2: DAC A,OLDCH
02900 MOVEI A,"."
03000 RATOM3: LDB B,RDFLD
03100 HRRI R,DELCLS ;delimiter
03200 AOS (P) ;non-atom (ie a delimiter)
03300 POPJ P,
03400
03500 ;dot handler
03600 RDOT: PUSHJ P,TYID
03700 LDB B,DOTFLD
03800 JRST DOTAB(B)
03900
04000 DOTAB: PUSHJ P,COMMENT ;0 comment
04100 JRST RDOT ;1 null
04200 JRST RDOT2 ;2 delimit
04300 JRST RDOT2 ;3 dot
04400 JRST RDOT2 ;4 e
04500 MOVEI B,0 ;5 digit
04600 IDPB B,C
04700 TLO T,SAWDOT
04800 JRST RDNUM
00100 ;string scanner
00200 STRTAB: PUSHJ P,COMMENT ;0 comment
00300 JRST RDSTR+1 ;1 null
00400 JRST STR2 ;2 delimit
00500 RDSTR: IDPB A,C ;3 string element
00600 PUSHJ P,TYID
00700 LDB B,STRFLD
00800 JRST STRTAB(B)
00900
01000 STR2: MOVEI A,DBLQT
01100 HRRI R,STRCLS ;string
01200 IDPB A,C
01300 NOINTR: PUSHJ P,IDEND ;no intern
01400 PUSHJ P,IDSUB
01500 JRST PNAMAK
01600
01700
01800 ;identifier scanner
01900 IDTAB: PUSHJ P,COMMENT ;0
02000 JRST RDID+1 ;1 null
02100 JRST MAKID ;2 delimit
02200 PUSHJ P,TYI ;3 /
02300 RDID: IDPB A,C ;4 letter or digit
02400 PUSHJ P,TYID
02500 LDB B,IDFLD
02600 JRST IDTAB(B)
02700
00100 ;number scanner
00200 NUMTAB: PUSHJ P,COMMENT ;0 comment
00300 JRST RDNUM+1 ;1 null
00400 JRST NUMAK ;2 delimit
00500 JRST RDNDOT ;3 dot
00600 JRST RDE ;4 e
00700 RDNUM: IDPB A,C ;5 digit
00800 PUSHJ P,TYID
00900 LDB B,NUMFLD
01000 JRST NUMTAB(B)
01100
01200 RDNDOT: TLOE T,SAWDOT
01300 JRST NUMAK ;two dots - delimit
01400 MOVEI A,0
01500 JRST RDNUM
01600
01700 RDNMIN: TLO T,MINSGN
01800 JRST RDNUM+1
01900
02000 ;exponent scanner
02100 RDE: TLO T,EXP
02200 MOVEI A,0
02300 IDPB A,C
02400 PUSHJ P,TYID
02500 CAIN A,"-"
02600 TLOA T,NEXP
02700 CAIN A,"+"
02800 JRST RDE2+1
02900 JRST RDE2+2
03000
03100 EXPTAB: PUSHJ P,COMMENT ;0
03200 JRST RDE2+1 ;1 null
03300 JRST NUMAK ;2 delimit
03400 RDE2: IDPB A,C ;3 digit
03500 PUSHJ P,TYID
03600 LDB B,EXPFLD
03700 JRST EXPTAB(B)
00100 ;semantic routines
00200 ;identifier interner and builder
00300
00400 IDEND: TDZA A,A
00500 IDEND1: IDPB A,C
00600 TLNE C,760000
00700 JRST IDEND1
00800 POPJ P,
00900
01000 MAKID: DAC A,OLDCH
01100 PUSHJ P,IDEND
01200 SKIPE NOINFG
01300 JRST NOINTR ;dont intern it
01400 INTER0: PUSHJ P,IDSUB
01500 PUSHJ P,INTER1 ;is it in oblist
01600 POPJ P, ;found
01700 PUSHJ P,PNAMAK ;not there
01800 MAKID2: LAC C,CURBUC ;
01900 CAR B,(C)
02000 PUSHJ P,CONS ;cons it into the oblist
02100 DIP A,(C)
02200 JRST CAR.
02300 CURBUC: 0
02400
02500 ;pname unmaker
02600 PNAMUK:
02700 FOO MOVEI B,PNAME
02800 PUSHJ P,GET
02900 JUMPE A,NOPNAM
03000 LAC C,SP
03100 PNAMU3: CAR B,(A)
03200 PUSH C,(B)
03300 CDR A,(A)
03400 JUMPN A,PNAMU3
03500 POPJ P,
03600
03700 ;idsub constructs a iowd pointer for a print name
03800 IDSUB: HRRZS C
03900 CAML C,endSPD ;top of spec pdl
04000 JRST SPDLOV
04100 MOVNS C
04200 ADDI C,(SP)
04300 HRLI C,1(SP)
04400 MOVSM C,IDPTR#
04500 POPJ P,
04600
00100 ;identifier interner
00200 INTER1: LAC B,1(SP) ;get first word of pname
00300 LSH B,-1 ;right justify it
00400 INT1: IDIVI B,BCKETS+X ;compute hash code
00500 RHX2: ADD C,ORGHWS
00600 CAR TT,(C) ;get bucket
00700 DAC C,CURBUC ;save bucket number
00800 LAC T,TT
00900 JRST MAKID1
01000
01100 MAKID3: LAC TT,T ;save previous atom
01200 CDR T,(T) ;get next atom
01300 MAKID1: JUMPE T,CPOPJ1 ;not in oblist
01400 CAR A,(T) ;next id in oblist
01500 MAKID4: CDR A,(A)
01600 JUMPE A,NOPNAM ;no print name
01700 LAC A,(A)
01800 CAR C,A
01900 FOO CAIE C,PNAME
02000 JRST MAKID4
02100 LAC C,IDPTR ;found pname
02200 CAR A,(A)
02300 MAKID5: JUMPE A,MAKID3 ;not the one
02400 MOVS A,(A)
02500 LAC B,(A)
02600 ANDCAM AR1,(C) ;clear low bit
02700 CAME B,(C)
02800 JRST MAKID3 ;not the one
02900 CAR A,A ;ok so far
03000 AOBJN C,MAKID5
03100 JUMPN A,MAKID3 ;not the one
03200 CAR A,(T) ;this is it
03300 CAR B,(TT)
03400 DIP A,(TT)
03500 DIP B,(T)
03600 POPJ P,
03700
03800 ;pname builder
03900 PNAMAK: LAC T,IDPTR
04000 PUSHJ P,NCONS
04100 LAC TT,A
04200 LAC C,A
04300 PNAMB: LAC A,(T)
04400 TRZ A,1 ;clear low bit!!!!!
04500 PUSHJ P,FWCONS
04600 PUSHJ P,NCONS
04700 DAP A,(TT)
04800 LAC TT,A
04900 AOBJN T,PNAMB
05000 LAC A,C
05100 HRLZS (A)
05200 JRST PNGNK1+1
00100 ;number builder
00200 NUMAK: DAC A,OLDCH
00300 HRRI R,NUMCLS ;number
00400 MOVEI A,0
00500 IDPB A,C
00600 IDPB A,C
00700 HRRZS C
00800 CAML C,endSPD ;top of spec pdl
00900 JRST SPDLOV
01000 MOVSI C,(<POINT 7,0,35>)
01100 HRRI C,(SP)
01200 TLNE T,SAWDOT+EXP
01300 JRST NUMAK2 ;decimal number or flt pt
01400 FOO LAC A,VIBASE ;ibase integrer
01500 SUBI A,INUM0
01600 PUSHJ P,NUM
01700 NUMAK4:
01800 FOO MOVEI B,FIXNUM
01900 NUMAK6: TLNE T,MINSGN
02000 MOVNS A
02100 JRST MAKNUM
02200
02300 NUMAK2: PUSHJ P,NUM10
02400 DAC A,TT
02500 TLNN T,SAWDOT
02600 JRST [ PUSHJ P,FLOAT ;flt pt without fraction
02700 LAC TT,A
02800 JRST NUMAK3]
02900 PUSHJ P,NUM10 ;fraction part
03000 EXCH A,TT
03100 TLNN T,EXP
03200 JUMPE AR2A,NUMAK4 ;no exponent and no fraction
03300 PUSHJ P,FLOAT
03400 EXCH A,TT
03500 PUSHJ P,FLOAT
03600 MOVEI AR1,FT01
03700 PUSHJ P,FLOSUB
03800 FMPR A,B
03900 FADRM A,TT
04000 NUMAK3: PUSHJ P,NUM10 ;exponent part
04100 LAC AR2A,A
04200 MOVEI AR1,FT-1
04300 TLNE T,NEXP
04400 MOVEI AR1,FT01 ;-exponent
04500 PUSHJ P,FLOSUB
04600 FMPR TT,B ;positive exponent
04700 FOO MOVEI B,FLONUM
04800 LAC A,TT
04900 JFCL 10,FLOOV
05000 JRST NUMAK6
05100
05200 FLOSUB: MOVSI B,(1.0)
05300 TRZE AR2A,1
05400 FMPR B,(AR1)
05500 JUMPE AR2A,CPOPJ
05600 LSH AR2A,-1
05700 SOJA AR1,FLOSUB+1
05800
05900 ;variable radix integer builder
06000
06100 NUM10: MOVEI A,TEN
06200 NUM: DAP A,NUM1
06300 JFCL 10,.+1 ;clear CARRY0 flag
06400 SETZB A,AR2A
06500 NUM2: ILDB B,C
06600 JUMPE B,CPOPJ ;done
06700 NUM1: IMULI A,X
06800 ADDI A,-"0"(B)
06900 NUM3: JFCL 10,FIXOV ;bignums change this to JFCL 10,RDBNM
07000 AOJA AR2A,NUM2
00100 INTERN: DAC A,AR2A
00200 PUSHJ P,PNAMUK
00300 PUSHJ P,IDSUB
00400 MOVEI AR1,1
00500 PUSHJ P,INTER1 ;is it in oblist
00600 POPJ P, ;found it
00700 LAC A,AR2A ;not there
00800 JRST MAKID2 ;put it there
00900
01000 REMOB: JUMPE A,FALSE
01100 MOVEI AR1,1
01200 PUSH P,A
01300 CAR A,(A)
01400 PUSHJ P,INTERN
01500 CAR B,@(P)
01600 CAME A,B
01700 JRST REMOB2
01800 CDR B,CURBUC
02000 CAR C,(B)
02100 CAR T,(C)
02200 CAMN T,A
02300 JRST [ CDR TT,(C)
02400 DIP TT,(B)
02500 JRST REMOB2]
02600 REMOB3: LAC TT,C
02700 CDR C,(C)
02800 CAR T,(C)
02900 CAME T,A
03000 JRST REMOB3
03100 CDR T,(C)
03200 DAP T,(TT)
03300 REMOB2: POP P,A
03400 CDR A,(A)
03500 JRST REMOB